home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Workbench Add-On
/
Workbench Add-On - Volume 1.iso
/
BBS-Archive
/
Dev
/
GNU-TILE-FORTH.lha
/
lib
/
structures.f83
< prev
Wrap
Text File
|
1992-05-19
|
4KB
|
144 lines
\
\ STRUCTURE DEFINITIONS
\
\ Copyright (C) 1988-1990 by Mikael R.K. Patel
\
\ Computer Aided Design Laboratory (CADLAB)
\ Department of Computer and Information Science
\ Linkoping University
\ S-581 83 LINKOPING
\ SWEDEN
\
\ Email: mip@ida.liu.se
\
\ Started on: 30 June 1988
\
\ Last updated on: 3 August 1990
\
\ Dependencies:
\ (forth) forth
\
\ Description:
\ Allows aggregates of data to be described as structures. General-
\ ization of structures in traditional programming languages. Allows
\ definition, initialization and action part. Basic object based
\ action may be defined in a style similar to the "does" section of
\ a creating word.
\
\ Copying:
\ This program is free software; you can redistribute it and\or modify
\ it under the terms of the GNU General Public License as published by
\ the Free Software Foundation; either version 1, or (at your option)
\ any later version.
\
\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
\ GNU General Public License for more details.
\
\ You should have received a copy of the GNU General Public License
\ along with this program; see the file COPYING. If not, write to
\ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
.( Loading Structures definitions...) cr
vocabulary structures ( -- )
structures definitions
0 field +size ( struct.type -- addr) private
cell field +initiate ( struct.type -- addr) private
: as ( -- struct.type)
' >body ( Quote next symbol and access body)
[compile] literal ( If compiling generate a literal)
; immediate
: this ( -- addr)
last >body ( Access the body of the last symbol)
;
: initiate ( addr struct.type -- )
+initiate @ ?dup ( Access initiate. code pointer)
if >r else drop then ( If available perform initialization)
;
: make-struct ( struct.type -- addr)
here dup >r ( Save pointer to instance)
over +size @ allot ( Access size and allocate memory)
swap initiate r> ( Perform initialization)
; private
: new-struct ( -- addr)
[compile] as ( Take the next symbol, "as")
?compile make-struct ( And "make" an instance)
; immediate
: sizeof ( -- num)
' >body +size @ ( Access size of structure)
[compile] literal ( And make literal if compiling)
; immediate
: assign ( a b -- )
[compile] sizeof ?compile cmove ( Access size and assign instance)
; immediate
: not-equal ( a b -- bool)
[compile] sizeof ?compile -match ( Access size and match the blocks)
; immediate
: struct.type ( -- struct.type offset0)
create here 0 0 , 0 , ( Allocate initial struct information)
does> ( struct.type -- )
create make-struct drop ( Create a new instance)
;
: bytes ( offset1 n -- offset2)
over dup ( Check for zero offset)
if field + ( Create an access field of "n" bytes)
else
create , + immediate ( Create an efficient field)
does> ( field -- )
drop ( Does nothing at runtime )
then
;
: align ( offset1 -- offset2)
dup 1 and + ( Align field offset to even address)
;
: struct.field ( bytes -- )
create , nil , ( Create a predefined field type)
does> ( struct.field -- )
@ bytes ( At run-time create field names)
; private
: struct ( -- )
[compile] sizeof bytes ( Create a structure sized field name)
;
( Initial set of field names)
1 struct.field byte ( -- )
2 struct.field word ( -- )
4 struct.field long ( -- )
4 struct.field ptr ( -- )
4 struct.field enum ( -- )
: struct.init ( struct.type offset3 -- )
align over +size ! ( Assign size of structure type)
here swap +initiate ! ] ( And pointer to initialization code)
;
: struct.does ( -- )
[compile] does> ( Do what does-does)
; immediate compilation
: struct.end ( [] or [struct.type offset3] -- )
compiling ( Check compilation status)
if [compile] ; ( If compiling then end definition)
else swap +size ! then ( Else assign size of structure type)
; immediate
forth only